home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / hcons.scm.z / hcons.scm
Text File  |  2002-07-08  |  2KB  |  79 lines
  1. ;;; installed-scm-file
  2.  
  3. ;;;;     Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;; 
  20.  
  21.  
  22. (define-module  (ice-9 hcons))
  23.  
  24.  
  25. ;;; {Eq? hash-consing}
  26. ;;;
  27. ;;; A hash conser maintains a private universe of pairs s.t. if 
  28. ;;; two cons calls pass eq? arguments, the pairs returned are eq?.
  29. ;;;
  30. ;;; A hash conser does not contribute life to the pairs it returns.
  31. ;;;
  32.  
  33. (define-public (hashq-cons-hash pair n)
  34.   (modulo (logxor (hashq (car pair) 4194303)
  35.           (hashq (cdr pair) 4194303))
  36.       n))
  37.  
  38. (define-public (hashq-cons-assoc key l)
  39.   (and (not (null? l))
  40.        (or (and (pair? l)        ; If not a pair, use its cdr?
  41.         (pair? (car l))
  42.         (pair? (caar l))
  43.         (eq? (car key) (caaar l))
  44.         (eq? (cdr key) (cdaar l))
  45.         (car l))
  46.        (hashq-cons-assoc key (cdr l)))))
  47.  
  48. (define-public (hashq-cons-get-handle table key)
  49.   (hashx-get-handle hashq-cons-hash hashq-cons-assoc table key #f))
  50.  
  51. (define-public (hashq-cons-create-handle! table key init)
  52.   (hashx-create-handle! hashq-cons-hash hashq-cons-assoc table key init))
  53.  
  54. (define-public (hashq-cons-ref table key)
  55.   (hashx-ref hashq-cons-hash hashq-cons-assoc table key #f))
  56.  
  57. (define-public (hashq-cons-set! table key val)
  58.   (hashx-set! hashq-cons-hash hashq-cons-assoc table key val))
  59.  
  60. (define-public (hashq-cons table a d)
  61.   (car (hashq-cons-create-handle! table (cons a d) #f)))
  62.  
  63. (define-public (hashq-conser hash-tab-or-size)
  64.   (let ((table (if (vector? hash-tab-or-size)
  65.            hash-tab-or-size
  66.            (make-doubly-weak-hash-table hash-tab-or-size))))
  67.     (lambda (a d) (hashq-cons table a d))))
  68.  
  69.  
  70.  
  71.  
  72. (define-public (make-gc-buffer n)
  73.   (let ((ring (make-list n #f)))
  74.     (append! ring ring)
  75.     (lambda (next)
  76.       (set-car! ring next)
  77.       (set! ring (cdr ring))
  78.       next)))
  79.